home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C/C++ Users Group Library 1996 July
/
C-C++ Users Group Library July 1996.iso
/
vol_100
/
176_01
/
xldmem.c
< prev
next >
Wrap
Text File
|
1985-12-25
|
12KB
|
561 lines
/* xldmem - xlisp dynamic memory management routines */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
/* external variables */
extern NODE ***xlstack,***xlstkbase,***xlstktop;
extern NODE *obarray;
extern NODE *xlenv;
extern long total;
extern int anodes,nnodes,nsegs,nfree,gccalls;
extern struct segment *segs;
extern NODE *fnodes;
extern char buf[];
/* external procedures */
extern char *malloc();
extern char *calloc();
/* forward declarations */
FORWARD NODE *newnode();
FORWARD char *strsave();
FORWARD char *stralloc();
/* cons - construct a new cons node */
NODE *cons(x,y)
NODE *x,*y;
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
rplacd(val,y);
return (val);
}
/* consa - (cons x nil) */
NODE *consa(x)
NODE *x;
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
return (val);
}
/* consd - (cons nil x) */
NODE *consd(x)
NODE *x;
{
NODE *val;
val = newnode(LIST);
rplacd(val,x);
return (val);
}
/* cvstring - convert a string to a string node */
NODE *cvstring(str)
char *str;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,NULL);
val = newnode(STR);
val->n_str = strsave(str);
val->n_strtype = DYNAMIC;
xlstack = oldstk;
return (val);
}
/* cvcstring - convert a constant string to a string node */
NODE *cvcstring(str)
char *str;
{
NODE *val;
val = newnode(STR);
val->n_str = str;
val->n_strtype = STATIC;
return (val);
}
/* cvsymbol - convert a string to a symbol */
NODE *cvsymbol(pname)
char *pname;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,NULL);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvstring(pname));
xlstack = oldstk;
return (val);
}
/* cvcsymbol - convert a constant string to a symbol */
NODE *cvcsymbol(pname)
char *pname;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,NULL);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvcstring(pname));
xlstack = oldstk;
return (val);
}
/* cvsubr - convert a function to a subr or fsubr */
NODE *cvsubr(fcn,type)
NODE *(*fcn)(); int type;
{
NODE *val;
val = newnode(type);
val->n_subr = fcn;
return (val);
}
/* cvfile - convert a file pointer to a file */
NODE *cvfile(fp)
FILE *fp;
{
NODE *val;
val = newnode(FPTR);
setfile(val,fp);
setsavech(val,0);
return (val);
}
/* cvfixnum - convert an integer to a fixnum node */
NODE *cvfixnum(n)
FIXNUM n;
{
NODE *val;
val = newnode(INT);
val->n_int = n;
return (val);
}
/* cvflonum - convert a floating point number to a flonum node */
NODE *cvflonum(n)
FLONUM n;
{
NODE *val;
val = newnode(FLOAT);
val->n_float = n;
return (val);
}
/* newstring - allocate and initialize a new string */
NODE *newstring(size)
int size;
{
NODE ***oldstk,*val;
oldstk = xlsave(&val,NULL);
val = newnode(STR);
val->n_str = stralloc(size);
*getstring(val) = 0;
val->n_strtype = DYNAMIC;
xlstack = oldstk;
return (val);
}
/* newobject - allocate and initialize a new object */
NODE *newobject(cls,size)
NODE *cls; int size;
{
NODE *val;
val = newvector(size+1);
setelement(val,0,cls);
val->n_type = OBJ;
return (val);
}
/* newvector - allocate and initialize a new vector node */
NODE *newvector(size)
int size;
{
NODE ***oldstk,*vect;
int bsize;
/* establish a new stack frame */
oldstk = xlsave(&vect,NULL);
/* allocate a vector node and set the size to zero (in case of gc) */
vect = newnode(VECT);
vect->n_vsize = 0;
/* allocate memory for the vector */
bsize = size * sizeof(NODE *);
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
vect->n_vsize = size;
total += (long) bsize;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new vector */
return (vect);
}
/* newnode - allocate a new node */
LOCAL NODE *newnode(type)
int type;
{
NODE *nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1;
/* initialize the new node */
nnode->n_type = type;
rplacd(nnode,NIL);
/* return the new node */
return (nnode);
}
/* stralloc - allocate memory for a string adding a byte for the terminator */
LOCAL char *stralloc(size)
int size;
{
char *sptr;
/* allocate memory for the string copy */
if ((sptr = malloc(size+1)) == NULL) {
findmem();
if ((sptr = malloc(size+1)) == NULL)
xlfail("insufficient string space");
}
total += (long) (size+1);
/* return the new string memory */
return (sptr);
}
/* strsave - generate a dynamic copy of a string */
LOCAL char *strsave(str)
char *str;
{
char *sptr;
/* create a new string */
sptr = stralloc(strlen(str));
strcpy(sptr,str);
/* return the new string */
return (sptr);
}
/* strfree - free a string */
LOCAL strfree(str)
char *str;
{
total -= (long) (strlen(str)+1);
free(str);
}
/* findmem - find more memory by collecting then expanding */
findmem()
{
gc();
if (nfree < anodes)
addseg();
}
/* gc - garbage collect */
gc()
{
NODE ***p;
/* mark the obarray and the current environment */
mark(obarray);
mark(xlenv);
/* mark the evaluation stack */
for (p = xlstack; p < xlstktop; )
mark(**p++);
/* sweep memory collecting all unmarked nodes */
sweep();
/* count the gc call */
gccalls++;
}
/* mark - mark all accessible nodes */
mark(ptr)
NODE *ptr;
{
NODE *this,*prev,*tmp;
/* just return on nil */
if (ptr == NIL)
return;
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
while (TRUE) {
/* descend as far as we can */
while (TRUE) {
/* check for this node being marked */
if (this->n_flags & MARK)
break;
/* mark it and its descendants */
else {
/* mark the node */
this->n_flags |= MARK;
/* follow the left sublist if there is one */
if (livecar(this)) {
this->n_flags |= LEFT;
tmp = prev;
prev = this;
this = car(prev);
rplaca(prev,tmp);
}
/* otherwise, follow the right sublist if there is one */
else if (livecdr(this)) {
this->n_flags &= ~LEFT;
tmp = prev;
prev = this;
this = cdr(prev);
rplacd(prev,tmp);
}
else
break;
}
}
/* backup to a point where we can continue descending */
while (TRUE) {
/* check for termination condition */
if (prev == NIL)
return;
/* check for coming from the left side */
if (prev->n_flags & LEFT)
if (livecdr(prev)) {
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
this = cdr(prev);
rplacd(prev,tmp);
break;
}
else {
tmp = prev;
prev = car(tmp);
rplaca(tmp,this);
this = tmp;
}
/* otherwise, came from the right side */
else {
tmp = prev;
prev = cdr(tmp);
rplacd(tmp,this);
this = tmp;
}
}
}
}
/* vmark - mark a vector */
vmark(n)
NODE *n;
{
int i;
for (i = 0; i < getsize(n); ++i)
mark(getelement(n,i));
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL sweep()
{
struct segment *seg;
NODE *p;
int n;
/